home *** CD-ROM | disk | FTP | other *** search
/ Nibble Magazine / nib04.dsk / APPLE S.T.A.R. SYSTEM.bas < prev    next >
BASIC Source File  |  2023-02-26  |  23KB  |  525 lines
  1. 10  REM  *********************************
  2. 11  REM  **    APPLE *S*T*A*R* SYSTEM   **
  3. 12  REM  **   (INFORMATION STORAGE AND  **
  4. 13  REM  **       RETRIEVAL SYSTEM)     **
  5. 14  REM  **        BY MARK CAPELLA      **
  6. 15  REM  **    COPYRIGHT (C) 1981 BY    **
  7. 16  REM  **       MICRO-SPARC, INC.     **
  8. 17  REM  **      LINCOLN, MA. 01773     **
  9. 18  REM  *********************************
  10. 60  REM 
  11. 65  REM  REQUIRES 48K APPLE II OR APPLE II PLUS, APPLESOFT IN ROM, AND 1 DISK
  12. 100  REM  *** MAIN ROUTINE
  13. 125  GOSUB 1000: REM  MAIN TITLES
  14. 130  GOSUB 2000: REM  SETUP
  15. 135  GOSUB 3000: REM  MAIN PROGRM
  16. 140  GOSUB 4000: REM  SHUTDOWN
  17. 145  END 
  18. 1000  REM  *** SPLASH PAGE AND
  19. 1005  REM  *** DEBUGGING AIDS
  20. 1030  LET TRUE = 1
  21. 1035  LET FALSE = 0
  22. 1040  LET VIDEO = TRUE
  23. 1045  LET NOSIG = FALSE
  24. 1050  LET TESTING = FALSE
  25. 1051  LET DOS$ =  CHR$(4)
  26. 1052  ONERR  GOTO 30000
  27. 1060  REM 
  28. 1065  IF VIDEO  THEN  TEXT : HOME : NORMAL 
  29. 1070  IF NOSIG  THEN 1110
  30. 1075  VTAB 3: HTAB 8: PRINT "*************************": PRINT 
  31. 1080  HTAB 10: PRINT "APPLE ";: FLASH : PRINT "ST.A.R.";: NORMAL : PRINT " SYSTEM": PRINT 
  32. 1085  HTAB 8: PRINT "(STORAGE AND RETRIEVAL)"
  33. 1090  HTAB 12: PRINT "BY MARK CAPELLA ": PRINT 
  34. 1095  HTAB 9: PRINT "COPYRIGHT (C) 1981 BY": PRINT 
  35. 1100  HTAB 11: PRINT "MICRO-SPARC, INC."
  36. 1105  VTAB 15: HTAB 8: PRINT "*************************": PRINT 
  37. 1110  RETURN 
  38. 2000  REM  *** SETUP ROUTINE
  39. 2021 BL$ = "                                   "
  40. 2022 BL$ = BL$ +BL$ +BL$ +BL$ +BL$ +BL$ +BL$
  41. 2025  DIM FI$(50): REM  FIELD
  42. 2030  DIM FL$(50): REM  LENGTH
  43. 2045  LET NF = 0: REM  # FIELDS
  44. 2050  DIM RE$(50): REM  EXTRAS
  45. 2052 MR = 500
  46. 2055  DIM ID$(MR): REM  INDEXS
  47. 2060  LET NI = 0: REM  # INDEXS
  48. 2062  DIM TF(50): REM  TEMP FLDS
  49. 2063  DIM GT(50,2): REM  TOTALS
  50. 2065  REM 
  51. 2067  VTAB 23: INPUT "WHAT FILE WILL YOU BE USING : ";F$: IF F$ = ""  THEN 2067
  52. 2070  REM 
  53. 2075  GOSUB 17000: REM  INIT
  54. 2080  GOSUB 2100: REM  HEADERS
  55. 2082 IL = 1 + VAL(FL$(1)) +(2 *(NF -1)) +4 +1
  56. 2085  GOSUB 2200: REM  INDEXES
  57. 2095  RETURN 
  58. 2100  REM  *** GET HEADER STUFF
  59. 2125  IF TESTING  THEN  PRINT "HEADER READ..."
  60. 2130 RL = 0
  61. 2132 NF = 0: REM  START READ
  62. 2135  PRINT DOS$"OPEN "F$"@HEADER"
  63. 2140  PRINT DOS$"READ "F$"@HEADER"
  64. 2145 ERR = 0: IF   NOT ERR  THEN  INPUT FI$: GOTO 2155
  65. 2150  PRINT DOS$"CLOSE "F$"@HEADER": RETURN 
  66. 2155 NF = NF +1:FI$(NF) = FI$
  67. 2160  INPUT FL$(NF):RL = RL + VAL(FL$(NF)): GOTO 2145
  68. 2200  REM  *** GET RECORD INDEXS
  69. 2222  IF TESTING  THEN  PRINT "INDEXS READ..."
  70. 2225 ERR = 0: IF   NOT ERR  THEN  PRINT DOS$"OPEN "F$"@INDEXES,L"IL
  71. 2230  PRINT DOS$"READ "F$"@INDEXES,R1"
  72. 2235 ERR = 0: IF   NOT ERR  THEN  INPUT ID$: GOTO 2245
  73. 2240  PRINT DOS$"CLOSE "F$"@INDEXES": RETURN 
  74. 2245 NI = NI +1:ID$(NI) = ID$: GOTO 2235
  75. 3000  REM 
  76. 3010  REM  *** MAIN PROGRAM LOOP
  77. 3015  REM  *** HERE WE GET THE
  78. 3020  REM  *** COMMAND AND THEN
  79. 3025  REM  *** ACT ON IT
  80. 3050  GOSUB 5000: REM  MAIN MENU
  81. 3055  REM 
  82. 3060  GOSUB 6000: REM  DECIPHER
  83. 3065  GOTO 3050
  84. 4000  REM  *** SHUTDOWN
  85. 4097  GOSUB 1065: REM  DO TITLES
  86. 4100  PRINT DOS$"CLOSE"
  87. 4998  VTAB 21: PRINT "ASARM RUN COMPLETE."
  88. 4999  END 
  89. 5000  REM  *** MAIN MENU
  90. 5025  IF VIDEO  THEN  TEXT : HOME : NORMAL 
  91. 5030  VTAB 1: PRINT "THE FOLLOWING OPTIONS ARE AVAILABLE : ": PRINT : PRINT 
  92. 5032  PRINT "      SHOW) SHOW THE RECORD LAYOUT": PRINT 
  93. 5035  PRINT "     ENTER) ENTER A DATA RECORD"
  94. 5040  PRINT "    DELETE) DELETE A DATA RECORD"
  95. 5045  PRINT "    MODIFY) MODIFY A DATA RECORD"
  96. 5050  PRINT "   DISPLAY) DISPLAY A DATA RECORD"
  97. 5052  PRINT "   RECOVER) RECOVER A DELETED RECORD"
  98. 5055  PRINT : PRINT "      LIST) LIST A SERIES OF RECORDS"
  99. 5057  PRINT "     DLIST) LIST ONLY DELETED RECORDS"
  100. 5060  PRINT "     PRINT) PRINT A SERIES OF RECORDS"
  101. 5061  PRINT "    DPRINT) PRINT ONLY DELETED RECORDS"
  102. 5062  PRINT : PRINT "      SORT) SORT THE RECORDS BY KEY"
  103. 5063  PRINT "    SEARCH) SEARCH FOR A RECORD"
  104. 5065  PRINT : PRINT "      STOP) STOP PROCESSING"
  105. 5075  VTAB 23: CALL  -868: INPUT "WHICH DO YOU WISH : ";RESPNSE$
  106. 5076  IF RE$ = ""  THEN 5075
  107. 5080 RE$ =  LEFT$(RE$,3): IF RE$ = "ENT"  OR RE$ = "DEL"  OR RE$ = "MOD"  OR RE$ = "DIS"  OR RE$ = "SOR"  OR RE$ = "LIS"  OR RE$ = "PRI"  OR RE$ = "STO"  OR RE$ = "REC"  OR RE$ = "SHO"  THEN  RETURN 
  108. 5081  IF RE$ = "DLI"  OR RE$ = "DPR"  OR RE$ = "SEA"  THEN  RETURN 
  109. 5085  VTAB 23: CALL  -868: PRINT "<<< THAT IS NOT ONE OF THE CHOICES >>>": FOR PAUSE = 1 TO 1500: NEXT PAUSE: GOTO 5075
  110. 6000  REM  *** COMMAND SWITCHING
  111. 6025  IF RE$ = "ENT"  THEN 10000: RETURN 
  112. 6035  IF RE$ = "DEL"  THEN 11000: RETURN 
  113. 6045  IF RE$ = "DIS"  THEN 12000: RETURN 
  114. 6055  IF RE$ = "MOD"  THEN 13000: RETURN 
  115. 6065  IF RE$ = "LIS"  THEN 14000: RETURN 
  116. 6066  IF RE$ = "DLI"  THEN 14000: RETURN 
  117. 6075  IF RE$ = "PRI"  THEN 14000: RETURN 
  118. 6076  IF RE$ = "DPR"  THEN 14000: RETURN 
  119. 6085  IF RE$ = "REC"  THEN 15000: RETURN 
  120. 6095  IF RE$ = "SHO"  THEN 16000: RETURN 
  121. 6105  IF RE$ = "SOR"  THEN 19000: RETURN 
  122. 6107  IF RE$ = "SEA"  THEN 20000: RETURN 
  123. 6115  IF RE$ = "STO"  THEN  POP : RETURN 
  124. 6125  RETURN 
  125. 10000  REM  *** ENTER RECORD
  126. 10025  IF VIDEO  THEN  TEXT : HOME : NORMAL 
  127. 10030  GOSUB 10100: REM  GET REC#
  128. 10032  IF RN >MR  THEN  VTAB 23: INPUT "THERE IS NO MORE MEMORY SPACE AVAILABLE FOR YOU TO STORE RECORDS. HIT RETURN    WHEN YOU ARE READY TO CONTINUE : ";RE$: RETURN 
  129. 10035  GOSUB 10200: REM  ENTER IT
  130. 10036  IF I = 1  AND RE$(I) = ""  THEN  RETURN 
  131. 10037  GOSUB 10300: REM  DISPLAY
  132. 10040  IF RE$ = "Y"  THEN  GOSUB 10400: REM  OUTPUT IT
  133. 10050  GOTO 10025
  134. 10100  REM  *** GET A RECORD#
  135. 10115  REM  *** TO ENTER DATA
  136. 10130  IF NI = 0  THEN 10150
  137. 10135  FOR I = 1 TO NI
  138. 10140  IF  LEFT$(ID$(I),1) = "/"  THEN RN =  VAL( RIGHT$(ID$(I),4)):IN = I: RETURN 
  139. 10145  NEXT 
  140. 10150 RN = NI +1:IN = RN: RETURN 
  141. 10200  REM  *** ENTER INFO
  142. 10205  REM 
  143. 10225  IF VIDEO  THEN  TEXT : HOME : NORMAL 
  144. 10230  VTAB 1: PRINT "<<< ENTERING RECORD "RN" >>>": VTAB 5
  145. 10235  FOR I = 1 TO NF
  146. 10240  PRINT FI$(I)": ";: FOR J = 1 TO  VAL(FL$(I)): PRINT  CHR$(95);: NEXT : FOR J = 1 TO  VAL(FL$(I)): PRINT  CHR$(8);: NEXT : INPUT "";RE$(I)
  147. 10241  IF I = 1  AND RE$(I) = ""  THEN  RETURN 
  148. 10245  IF  LEN(RE$(I)) > VAL(FL$(I))  THEN 10240
  149. 10250  IF  LEN(RE$(I)) < VAL(FL$(I))  THEN RE$(I) = RE$(I) + LEFT$(BL$, VAL(FL$(I)) - LEN(RE$(I)))
  150. 10255  NEXT I
  151. 10265  RETURN 
  152. 10300  REM  *** REPRINT RECORD
  153. 10325  TEXT : HOME 
  154. 10330  VTAB 1: PRINT "<<< THE FOLLOWING INFO WAS ENTERED >>>"
  155. 10335  VTAB 5: FOR I = 1 TO NF: PRINT FI$(I)": "RE$(I): NEXT 
  156. 10340  VTAB 22: CALL  -958: INPUT "IS THIS CORRECT : ";RE$:RE$ =  LEFT$(RE$,1): IF RE$ < >"Y"  AND RE$ < >"N"  THEN  PRINT "": GOTO 10340
  157. 10345  RETURN 
  158. 10400  REM  *** DATA IS OK
  159. 10423 ERR = 0: IF   NOT ERR  THEN  PRINT DOS$"OPEN "F$"@DATA,L"RL +1: GOTO 10425
  160. 10424  VTAB 23: CALL  -958: PRINT "THERE IS NO MORE ROOM FOR DATA": FOR PA = 1 TO 1000: NEXT PA: GOTO 10999
  161. 10425  PRINT DOS$"WRITE "F$"@DATA,R"RN
  162. 10430  FOR I = 1 TO NF
  163. 10432 ERR = 0: IF   NOT ERR  THEN  PRINT RE$(I);: GOTO 10434
  164. 10433  VTAB 23: CALL  -958: PRINT "THERE IS NO MORE ROOM ON DISK...": FOR PA = 1 TO 1000: NEXT PA: PRINT DOS$"CLOSE "F$"@DATA": GOTO 10999
  165. 10434  NEXT I: PRINT 
  166. 10435  PRINT DOS$"CLOSE "F$"@DATA"
  167. 10440  IF RN >NI  THEN NI = RN
  168. 10445 ID$(IN) = ">" +RE$(1): IF NF >1  THEN  FOR I = 2 TO NF:ID$(IN) = ID$(IN) + LEFT$(RE$(I) +" ",2): NEXT 
  169. 10447 ID$(IN) = ID$(IN) + RIGHT$("0000" + STR$(RN),4)
  170. 10450  PRINT DOS$"CLOSE "F$"@DATA"
  171. 10460 ERR = 0: IF   NOT ERR  THEN  PRINT DOS$"OPEN "F$"@INDEXES,L"IL: GOTO 10463
  172. 10461  VTAB 23: CALL  -958: PRINT "THERE IS NO MORE ROOM FOR DATA...": FOR PA = 1 TO 1000: NEXT PA: GOTO 10999
  173. 10463  IF TESTING  THEN  PRINT "INDEX : "IL: PRINT "RN = "IN
  174. 10465  PRINT DOS$"WRITE "F$"@INDEXES,R"IN
  175. 10470 ERR = 0: IF   NOT ERR  THEN  PRINT ID$(IN): GOTO 10475
  176. 10472  VTAB 23: CALL  -958: PRINT "THERE IS NO MORE ROOM FOR DATA...": FOR PA = 1 TO 1000: NEXT PA
  177. 10475  PRINT DOS$"CLOSE "F$"@INDEXES"
  178. 10999  RETURN 
  179. 11000  REM  *** DELETE RECORD
  180. 11025  GOSUB 12100: REM  GET REC#
  181. 11030  IF RE$ = ""  THEN  RETURN 
  182. 11035  GOSUB 12200: REM  FIND IT
  183. 11040  IF   NOT FO  THEN 11025
  184. 11042 IN = FO:FO =  VAL( RIGHT$(ID$(FO),4))
  185. 11045  GOSUB 12300: REM  GET IT
  186. 11050  GOSUB 12400: REM  DISPLAY
  187. 11055  VTAB 23: CALL  -868: INPUT "TYPE DELETE OR RETURN TO ABORT : ";RE$
  188. 11060  IF RE$ < >"DELETE"  THEN 11025
  189. 11065 ID$(IN) = "/" + MID$ (ID$(IN),2): GOSUB 10460
  190. 11999  GOTO 11025
  191. 12000  REM  *** DISPLAY RECORD
  192. 12030  GOSUB 12100: REM  GET REC#
  193. 12031  IF RE$ = ""  THEN  RETURN 
  194. 12035  GOSUB 12200: REM  FIND IT
  195. 12040  IF   NOT FO  THEN 12030
  196. 12042 FO =  VAL( RIGHT$(ID$(FO),4))
  197. 12045  GOSUB 12300: REM  GET IT
  198. 12050  GOSUB 12400: REM  DISPLAY
  199. 12055  VTAB 23: CALL  -868: INPUT "HIT RETURN WHEN READY TO CONTINUE : ";RE$
  200. 12099  GOTO 12030
  201. 12100  REM  *** GET A RECORD#
  202. 12125  VTAB 23: CALL  -868: INPUT "WHAT IS THE RECORD IDENTIFIER : ";RE$
  203. 12126  IF RE$ = ""  THEN  RETURN 
  204. 12130  IF  LEN(RE$) > VAL(FL$(1))  THEN  VTAB 23: CALL  -868: PRINT "THE RECORD NUMBER IS " VAL(FL$(1))" CHARACTERS LONG": FOR PA = 1 TO 1000: NEXT PA: GOTO 12125
  205. 12135  IF  LEN(RE$) < VAL(FL$(1))  THEN RE$ =  LEFT$("000000", VAL(FL$(1)) - LEN(RE$)) +RE$
  206. 12195  RETURN 
  207. 12200  REM  *** FIND THE RECORD
  208. 12222 FOUND = FALSE
  209. 12224  IF NI <1  THEN 12240
  210. 12225  FOR I = 1 TO NI
  211. 12227  IF  LEFT$(ID$(I),1) = "/"  THEN 12235
  212. 12230  IF  MID$ (ID$(I),2, VAL(FL$(1))) = RE$  THEN FOUND = I: GOTO 12240
  213. 12235  NEXT 
  214. 12240  IF   NOT FOUND  THEN  VTAB 23: CALL  -868: PRINT "THAT RECORD IS NOT ON FILE": FOR PA = 1 TO 1000: NEXT PA
  215. 12299  RETURN 
  216. 12300  REM  *** GET THE RECORD
  217. 12315  REM  *** FROM THE DISK
  218. 12327  PRINT DOS$"OPEN "F$"@DATA,L"RL +1
  219. 12330  PRINT DOS$"READ "F$"@DATA,R"FOUND
  220. 12335  INPUT RE$: REM  GET WHOLE INFO
  221. 12340 TMP = 1: FOR I = 1 TO NF
  222. 12345 RE$(I) =  MID$ (RE$,TMP, VAL(FL$(I))):TMP = TMP + VAL(FL$(I))
  223. 12350  NEXT I
  224. 12355  PRINT DOS$"CLOSE "F$"@DATA"
  225. 12399  RETURN 
  226. 12400  REM  *** DISPLAY THE REC
  227. 12425  HOME : VTAB 1: PRINT "<<< DISPLAY OF RECORD "RE$(1)" >>>": VTAB 5
  228. 12430  FOR I = 1 TO NF
  229. 12435  PRINT FI$(I)": ";RE$(I)
  230. 12440  NEXT I
  231. 12499  RETURN 
  232. 12999  RETURN 
  233. 13000  REM  *** MODIFY RECORD
  234. 13030  GOSUB 12100: REM  GET REC#
  235. 13031  IF RE$ = ""  THEN  RETURN 
  236. 13035  GOSUB 12200: REM  FIND IT
  237. 13040  IF   NOT FO  THEN 13030
  238. 13042 IN = FO:FO =  VAL( RIGHT$(ID$(FO),4))
  239. 13045  GOSUB 12300: REM  GET IT
  240. 13050  GOSUB 13100: REM  MODIFY
  241. 13055  GOSUB 10300: REM  DISPLAY
  242. 13060  IF RE$ = "Y"  THEN  GOSUB 10400: REM  OUTPUT IT
  243. 13099  GOTO 13030
  244. 13100  REM  *** MODIFY THE REC
  245. 13122 RN = FOUND
  246. 13125  TEXT : HOME : VTAB 1
  247. 13130  PRINT "<<< MODIFYING RECORD "RN" >>>": VTAB 5
  248. 13135  FOR I = 1 TO NF
  249. 13140  PRINT FI$(I)": ";RE$(I);: FOR J = 1 TO  VAL(FL$(I)): PRINT  CHR$(8);: NEXT : INPUT "";RE$
  250. 13145  IF  LEN(RE$) > VAL(FL$(I))  THEN 13140
  251. 13147  IF RE$ = ""  THEN  VTAB ( PEEK(37)): CALL  -958: PRINT FI$(I)": "RE$(I): GOTO 13160
  252. 13150  IF  LEN(RE$) < VAL(FL$(I))  THEN RE$ = RE$ + LEFT$(BL$, VAL(FL$(I)) - LEN(RE$))
  253. 13155 RE$(I) = RE$
  254. 13160  NEXT 
  255. 13199  RETURN 
  256. 13999  RETURN 
  257. 14000  REM  *** LIST / PRINTER
  258. 14020  REM 
  259. 14022 PRNTR = (RE$ = "PRI"  OR RE$ = "DPR")
  260. 14023 DLTD = (RE$ = "DLI"  OR RE$ = "DPR")
  261. 14025  GOSUB 14100: REM  GET FLDS
  262. 14026  GOSUB 14600
  263. 14030  IF TP  THEN  GOSUB 14200: REM  DISPLAY FIELDS
  264. 14099  RETURN 
  265. 14100  REM  *** GET FIELDS TO BE
  266. 14112  REM  ***   DISPLAYED
  267. 14125  LET TP = 0
  268. 14130  VTAB 23: CALL  -868: INPUT "FIELD TO LIST (OR RETURN) : ";RE$
  269. 14132  IF RE$ = ""  THEN 14170
  270. 14135  FOR I = 1 TO NF
  271. 14140  IF RE$ = FI$(I)  THEN 14160
  272. 14145  NEXT I
  273. 14150  VTAB 23: CALL  -868: PRINT "THAT FIELD DOES NOT EXIST.": FOR PA = 1 TO 1000: NEXT PA: GOTO 14130
  274. 14160 TP = TP +1:TF(TP) = I
  275. 14165  IF TP <50  THEN 14130
  276. 14170  RETURN 
  277. 14200  REM  *** ACTUAL DISPLAY
  278. 14221  IF NI =  <1  THEN  RETURN 
  279. 14222  IF PRNTR  THEN  PRINT DOS$"PR#1": PRINT  CHR$(9)"80N"
  280. 14223 ERR = 0: IF   NOT ERR  THEN  PRINT DOS$"OPEN "F$"@DATA,L"RL +1: GOTO 14226
  281. 14224  VTAB 23: CALL  -958: PRINT "THERE IS NO MORE ROOM FOR DATA...": FOR PA = 1 TO 1000: NEXT PA: GOTO 14267
  282. 14226  GOSUB 14300: REM  DO TITLE
  283. 14227  FOR I = 1 TO NI
  284. 14230 FO =  VAL( RIGHT$(ID$(I),4)): GOSUB 14400: REM  GET AND DISSECT RECORD
  285. 14232  IF DLTD  AND  LEFT$(ID$(I),1) < >"/"  THEN 14260
  286. 14233  IF   NOT DLTD  AND  LEFT$(ID$(I),1) = "/"  THEN 14260
  287. 14235  FOR J = 1 TO TP
  288. 14240  PRINT RE$(TF(J))" ";
  289. 14245  NEXT J: PRINT 
  290. 14247  FOR J = 1 TO GT:GT(J,2) = GT(J,2) + VAL(RE$(GT(J,1))): NEXT J
  291. 14255  IF   NOT PRNTR  AND  PEEK(37) >20  THEN  GOSUB 14500
  292. 14260  NEXT I
  293. 14262  PRINT : IF   NOT GT  THEN  PRINT : PRINT : GOTO 14265
  294. 14263  GOSUB 14800: REM  TOTALS
  295. 14265  IF PRNTR  THEN  PRINT DOS$"PR#0"
  296. 14267  PRINT DOS$"CLOSE "F$"@DATA"
  297. 14270  VTAB 23: CALL  -868: INPUT "HIT RETURN WHEN READY TO CONTINUE : ";RE$
  298. 14299  RETURN 
  299. 14300  REM  *** PRINT TITLES
  300. 14322  IF VIDEO  THEN  TEXT : HOME : NORMAL 
  301. 14325 TMP = 1
  302. 14330  FOR J = 1 TO TP
  303. 14335 TMP$ = FI$(TF(J)):TMP =  VAL(FL$(TF(J)))
  304. 14340  IF  LEN(TM$) > = TM  THEN TM$ =  LEFT$(TM$,TM): GOTO 14350
  305. 14345 TM$ = TM$ + LEFT$(BL$,TM - LEN(TM$))
  306. 14350  PRINT TM$" ";: NEXT : PRINT : PRINT "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^": PRINT 
  307. 14399  RETURN 
  308. 14400  REM  *** GET RECORDS FOR
  309. 14415  REM  *** LIST / PRINTING
  310. 14425  PRINT DOS$"READ "F$"@DATA,R"FOUND
  311. 14430  INPUT RE$: REM  GET WHOLE INFO
  312. 14435 TMP = 1: FOR J = 1 TO NF
  313. 14440 RE$(J) =  MID$ (RE$,TMP, VAL(FL$(J))):TMP = TMP + VAL(FL$(J))
  314. 14445  NEXT J
  315. 14450  PRINT DOS$
  316. 14455  RETURN 
  317. 14500  REM  *** PAUSE FOR DELAY
  318. 14525  VTAB 23: PRINT "S TO STOP, OR RETURN TO CONTINUE : ";: GET TMP$
  319. 14530  IF TMP$ = "S"  THEN  POP : RETURN 
  320. 14535  GOSUB 14300: REM  TITLES
  321. 14540  RETURN 
  322. 14600  REM  *** GET TOTAL FIELDS
  323. 14625  LET GT = 0
  324. 14630  VTAB 23: CALL  -868: INPUT "FIELD TO TOTAL (OR RETURN) : ";RE$
  325. 14635  IF RE$ = ""  THEN 14670
  326. 14640  FOR I = 1 TO NF: IF RE$ = FI$(I)  THEN 14660
  327. 14645  NEXT I
  328. 14650  VTAB 23: CALL  -868: PRINT "THAT FIELD DOES NOT EXIST.": FOR PA = 1 TO 1000: NEXT PA: GOTO 14630
  329. 14660 GT = GT +1:GT(GT,1) = I:GT(GT,2) = 0
  330. 14665  IF GT <50  THEN 14630
  331. 14670  RETURN 
  332. 14700  REM  *** FORMAT A STRING
  333. 14723 ZZ =  VAL(FL$(TFD(J)))
  334. 14725  IF XX <0  THEN XX =  ABS(XX): GOSUB 14730:XX$ = "-" + RIGHT$(XX$,ZZ -1): RETURN 
  335. 14730 XX$ =  RIGHT$("0000000000000000" + STR$( INT(XX +.005)) +"." + RIGHT$( STR$( INT((XX +100) *100 +.5)),2),ZZ +3)
  336. 14800  REM  DO TOTALS
  337. 14822  PRINT "TOTALS^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^"
  338. 14825 TMP = 1: FOR J = 1 TO TP
  339. 14830  FOR K = 1 TO GT: IF GT(K,1) < >TF(J)  THEN  NEXT : PRINT  LEFT$(BL$, VAL(FL$(TF(J))))" ";: GOTO 14840
  340. 14835 XX = GT(K,2): GOSUB 14700: PRINT XX$" ";
  341. 14840  NEXT J: PRINT : PRINT : PRINT : RETURN 
  342. 14999  RETURN 
  343. 15000  REM  *** RECOVER DELETED
  344. 15012  REM  ***    RECORD
  345. 15025  GOSUB 12100: REM  GET REC#
  346. 15030  IF RE$ = ""  THEN  RETURN 
  347. 15035  GOSUB 15100: REM  FIND IT
  348. 15040  IF FOUND  THEN  GOSUB 15200: REM  RECOVER IT
  349. 15099  GOTO 15025
  350. 15100  REM  *** FIND IT
  351. 15122 FOUND = FALSE
  352. 15124  IF NI <1  THEN 15140
  353. 15125  FOR I = 1 TO NI
  354. 15127  IF  LEFT$(ID$(I),1) = "/"  AND  MID$ (ID$(I),2, VAL(FL$(1))) = RE$  THEN FOUND = I: GOTO 15140
  355. 15135  NEXT 
  356. 15140  IF   NOT FOUND  THEN  VTAB 23: CALL  -868: PRINT "THAT RECORD IS NOT ON FILE": FOR PA = 1 TO 1000: NEXT PA
  357. 15199  RETURN 
  358. 15200  REM  *** RECOVER IT
  359. 15225 ID$(FO) = ">" + MID$ (ID$(FO),2):IN = FO: GOSUB 10460
  360. 15299  RETURN 
  361. 16000  REM  *** SHOW THE RECORD
  362. 16015  REM  ***    LAYOUT
  363. 16030  GOSUB 16100: REM  OUTPUT
  364. 16060  VTAB 23: CALL  -868: INPUT "HIT RETURN WHEN READY TO CONTINUE : ";RE$
  365. 16099  RETURN 
  366. 16100  REM  *** DISPLAY REC INFO
  367. 16125  TEXT : HOME : VTAB 1
  368. 16130  PRINT "<<< SHOWING THE RECORD LAYOUT >>>": VTAB 5
  369. 16135  FOR I = 1 TO NF
  370. 16140  PRINT FI$(I)": ";: FOR J = 1 TO  VAL(FL$(I)): PRINT  CHR$(95);: NEXT : HTAB 35: PRINT  VAL(FL$(I))
  371. 16150  NEXT 
  372. 16160  RETURN 
  373. 17000  REM  *** INITIALIZE
  374. 17025 ERR = 0: IF   NOT ERR  THEN  PRINT DOS$"OPEN "F$"@HEADER": GOTO 17030
  375. 17027  VTAB 23: CALL  -958: PRINT "THERE IS NO ROOM ON THIS DISK.": FOR PA = 1 TO 1000: NEXT PA: GOTO 4000: REM  ABORT !!!
  376. 17030  PRINT DOS$"READ "F$"@HEADER"
  377. 17035 ERR = FALSE: IF   NOT ERR  THEN  INPUT DUMMY$
  378. 17040  PRINT DOS$"CLOSE "F$"@HEADER"
  379. 17045  REM 
  380. 17050  IF ERR  THEN  PRINT  CHR$(4)"DELETE "F$"@HEADER": GOSUB 18000: REM  INIT
  381. 17055  RETURN 
  382. 18000  REM  *** DO INIT ROUTINE
  383. 18025  GOSUB 18900: REM  WANT TO?
  384. 18030  IF RE$ = "N"  THEN 4000: REM  BAIL-OUT ABORT METHOD
  385. 18035  GOSUB 18100: REM  DOIT !!!
  386. 18040  RETURN 
  387. 18100  REM  *** GET FIELD STUFF
  388. 18125  LET RL = 1: REM  RECORD LENGTH = DELCHAR + ...
  389. 18130  GOSUB 18200: REM  GET ENTRY
  390. 18135  IF XF$ < >""  THEN 18140
  391. 18137  IF NF >1  THEN  GOSUB 18500: RETURN : REM  WRITE TO FILE
  392. 18138  VTAB 23: CALL  -958: PRINT "AT LEAST ONE ITEM IS REQUIRED...": FOR PA = 1 TO 1000: NEXT PA: GOTO 18125
  393. 18140  IF RE$ = "Y"  THEN NF = NF +1:FI$(NF) = XF$:FL$(NF) = XL$:RL = RL + VAL(XL$)
  394. 18145  GOTO 18130
  395. 18200  REM  *** GET A FIELDNAME,
  396. 18215  REM  *** LENGTH AND STUFF
  397. 18230  IF VIDEO  THEN  TEXT : HOME : NORMAL 
  398. 18235  VTAB 1: PRINT "ENTER THE FOLLOWING INFORMATION : ": VTAB 5
  399. 18237  IF NF = 0  THEN  INPUT "ID (RETURN TO STOP) : ";XF$: GOTO 18242
  400. 18240  INPUT "FIELD NAME (RETURN TO STOP) : ";XF$
  401. 18242  IF XF$ = ""  THEN  RETURN 
  402. 18245  VTAB 6: CALL  -868: INPUT "FIELD LENGTH : ";XL$: IF  VAL(XL$) <1  THEN  PRINT "": GOTO 18245
  403. 18250  IF  VAL(XL$) +RL >245  THEN  VTAB 6: CALL  -868: PRINT "<<< RECORD LENGTH TOO LONG >>>": FOR PAUSE = 1 TO 1000: NEXT PAUSE: GOTO 18230
  404. 18285  VTAB 23: CALL  -868: INPUT "IS THIS CORRECT : ";RE$:RE$ =  LEFT$(RE$,1): IF RE$ < >"Y"  AND RE$ < >"N"  THEN  PRINT "";: GOTO 18285
  405. 18290  RETURN 
  406. 18500  REM  *** WRITE TO HEADER
  407. 18521  GOSUB 16100
  408. 18522  VTAB 23: CALL  -868: INPUT "IS THIS ALL CORRECT : ";RE$: IF  LEFT$(RE$,1) < >"Y"  AND  LEFT$(RE$,1) < >"N"  THEN 18522
  409. 18523  IF  LEFT$(RE$,1) = "N"  THEN 4000
  410. 18525  PRINT DOS$"OPEN "F$"@HEADER"
  411. 18530  PRINT DOS$"WRITE "F$"@HEADER"
  412. 18535  FOR I = 1 TO NF
  413. 18537 ERR = 0: IF   NOT ERR  THEN  PRINT FI$(I): IF   NOT ERR  THEN  PRINT FL$(I): GOTO 18539
  414. 18538  VTAB 23: CALL  -958: PRINT "THERE IS NO MORE ROOM FOR THIS HEADER": FOR PA = 1 TO 1000: NEXT PA: GOTO 4000: REM  BAIL OUT !!!
  415. 18539  NEXT 
  416. 18540  PRINT DOS$"CLOSE "F$"@HEADER"
  417. 18545  RETURN 
  418. 18900  REM  *** WANT TO DO IT?
  419. 18925  IF VIDEO  THEN  TEXT : HOME : NORMAL 
  420. 18930  VTAB 1: PRINT "*****   INITIALIZATION PROCEDURE   *****"
  421. 18935  VTAB 5: PRINT "   I'M SORRY, BUT THERE IS NO HEADER    FILE ON THIS DISK. INITIALIZATION MUST  BE DONE BEFORE ANY DATA CAN BE SAVED OR ACCESSED."
  422. 18940  PRINT : INPUT "DO YOU WISH TO INITIALIZE A DATA FILE ONTHE CURRENT DISKETTE? ";RESPNSE$
  423. 18945  IF  LEFT$(RE$,1) = "Y"  OR  LEFT$(RE$,1) = "N"  THEN RE$ =  LEFT$(RE$,1): RETURN 
  424. 18950  PRINT : PRINT "PLEASE ANSWER 'YES' OR 'NO'.": GOTO 18940
  425. 19000  REM  *** SORT ROUTINE
  426. 19025  HOME : VTAB 10: PRINT "***  SORT IN PROGRESS, DO NOT TOUCH  ***"
  427. 19030  GOSUB 19100: REM  SORT THE INDEXES IN MEMORY
  428. 19035  GOSUB 19200: REM  OUTPUT THE SORTED INDEXES
  429. 19040  RETURN 
  430. 19100  REM  *** SORT BY INDEX
  431. 19125 I = 0
  432. 19130 I = I +1
  433. 19135  IF ID$(I) <ID$(I +1)  THEN 19170
  434. 19140 TMP$ = ID$(I):ID$(I) = ID$(I +1):ID$(I +1) = TMP$
  435. 19145 J = I -1: IF J <1  THEN J = 1
  436. 19150  IF ID$(J) <ID$(J +1)  THEN 19135
  437. 19155 TMP$ = ID$(J):ID$(J) = ID$(J +1):ID$(J +1) = TMP$
  438. 19160 J = J -1: IF J <1  THEN J = 1
  439. 19165  GOTO 19150
  440. 19170  IF I <NI -1  THEN 19130
  441. 19175  RETURN 
  442. 19200  REM  *** OUTPUT INDEXES
  443. 19225  IF TESTING  THEN  PRINT "INDEXES OUTPUT..."
  444. 19230  PRINT DOS$"OPEN "F$"@INDEXES,L"IL
  445. 19235  PRINT DOS$"WRITE "F$"@INDEXES,R1"
  446. 19240  FOR I = 1 TO NI: PRINT ID$(I): NEXT 
  447. 19245  PRINT DOS$"CLOSE "F$"@INDEXES"
  448. 19250  RETURN 
  449. 20000  REM  *** SEARCH FOR A REC
  450. 20025  GOSUB 20100: REM  FIELD
  451. 20026  IF RE$ = ""  THEN  RETURN 
  452. 20027  IF   NOT RI  THEN  RETURN 
  453. 20030  GOSUB 20200: REM  ALL?
  454. 20035  GOSUB 20300: REM  CNSTNT
  455. 20037  IF RE$ = ""  THEN  RETURN 
  456. 20040  GOSUB 20400: REM  DO IT
  457. 20090  GOTO 20025
  458. 20100  REM  *** GET NEEDED FIELD
  459. 20125  VTAB 23: CALL  -868: INPUT "FIELD TO SEARCH ON : ";RE$
  460. 20130  IF RE$ = ""  THEN  RETURN 
  461. 20135  FOR RI = 1 TO NF
  462. 20140  IF RE$ = FI$(RI)  THEN 20155
  463. 20145  NEXT 
  464. 20150  VTAB 23: CALL  -868: PRINT "THAT FIELD DOES NOT EXIST.": FOR PA = 1 TO 1000: NEXT PA:RI = 0: RETURN 
  465. 20155  RETURN 
  466. 20200  REM  *** 2 OR ALL CHARS
  467. 20225  VTAB 23: CALL  -868: INPUT "ALL CHARACTER MATCH OR FIRST TWO : ";ALL$
  468. 20230 ALL$ =  LEFT$(ALL$,1): IF ALL$ = "A"  OR ALL$ = "A"  OR ALL$ = "F"  OR ALL$ = "F"  THEN  RETURN 
  469. 20235  VTAB 23: CALL  -868: PRINT "TYPE 'A' OR 'F' PLEASE.": FOR PA = 1 TO 1000: NEXT PA: GOTO 20225
  470. 20300  REM  *** GET CONSTANT
  471. 20325  VTAB 23: CALL  -868: INPUT "WHAT IS THE CONSTANT : ";RC$
  472. 20327  IF RC$ = ""  THEN  RETURN 
  473. 20330 R2$ =  LEFT$(RC$ +" ",2)
  474. 20335  IF  LEN(RC$) < VAL(FL$(RI))  THEN RC$ = RC$ + LEFT$(BL$, VAL(FL$(RI)) - LEN(RC$))
  475. 20340  IF  LEN(RC$) > VAL(FL$(RI))  THEN  VTAB 23: CALL  -868: PRINT "THE FIELD IS "FL$(RI)" CHARS LONG.": FOR PA = 1 TO 1000: NEXT :RC$ = ""
  476. 20345  IF RI = 1  THEN R2$ = RC$
  477. 20390  RETURN 
  478. 20400  REM  *** DO THE SEARCH
  479. 20422 ST = 1
  480. 20425  GOSUB 20500: REM  FIRST MATCH
  481. 20430  IF   NOT FO  THEN  RETURN 
  482. 20435  GOSUB 20600: REM  SECOND MATCH
  483. 20440  IF   NOT FO  THEN 20425
  484. 20450  GOSUB 12400: REM  DISPLAY
  485. 20455  GOSUB 20700: REM  INPUT
  486. 20460  GOTO 20425
  487. 20500  REM  *** GET NEXT MATCH
  488. 20522 R2 =  VAL(FL$(I)) +(2 *(RI -1)): IF RI = 1  THEN R2 = 2
  489. 20523 RT =  VAL(FL$(RI)): IF RI >1  THEN RT = 2
  490. 20524  IF ST >NI  THEN 20590
  491. 20525  FOR I = ST TO NI
  492. 20527 RT$ =  MID$ (ID$(I),R2,RT)
  493. 20535  IF RT$ = R2$  THEN FOUND =  VAL( RIGHT$(ID$(I),4)): GOTO 20595
  494. 20540  NEXT I
  495. 20590 FOUND = FALSE
  496. 20595 ST = I +1: RETURN 
  497. 20600  REM  *** GET RECORD/MATCH
  498. 20625  GOSUB 12300: REM  GET REC
  499. 20630  IF RE$(RI) = RC$  THEN FOUND = TRUE: RETURN 
  500. 20632  IF ALL$ = "F"  OR ALL$ = "F"  THEN FOUND = TRUE: RETURN 
  501. 20635 FOUND = FALSE: RETURN 
  502. 20700  REM  *** CONTINUE ?
  503. 20725  VTAB 23: HTAB 1: CALL  -868: PRINT "S TO STOP, OR RETURN TO CONTINUE : ";: GET TMP$
  504. 20730  IF TMP$ = "S"  OR TMP$ = "S"  THEN  POP : POP : RETURN 
  505. 20735  IF TMP$ =  CHR$(13)  THEN  PRINT : RETURN 
  506. 20740  GOTO 20725
  507. 30000  REM  *** ERROR RECOVERY
  508. 30015  REM  *** ROUTINES
  509. 30030 ERR =  PEEK(222)
  510. 30035  IF ERR = 5  THEN  RESUME : REM  * JUST AN END OF FILE *
  511. 30040  IF ERR = 9  THEN  RESUME : REM  * JUST A DISK FULL *
  512. 30045  IF ERR = 4  THEN  VTAB 23: CALL  -958: PRINT "THE DISK IS WRITE PROTECTED": FOR PA = 1 TO 1000: NEXT PA: GOTO 4000
  513. 30050  IF ERR = 8  THEN  VTAB 23: CALL  -958: PRINT "THE DISK HAD AN I/O ERROR": FOR PA = 1 TO 1000: NEXT PA: GOTO 4000
  514. 30055  IF ERR = 10  THEN  VTAB 23: CALL  -958: PRINT "A FILE IS LOCKED AND SHOULD NOT BE": FOR PA = 1 TO 1000: NEXT PA: GOTO 4000
  515. 30100  REM  *** UNEXPECTED ERROR
  516. 30125  IF VIDEO  THEN  TEXT : HOME : NORMAL 
  517. 30130  IF TESTING  THEN  POKE 216,0: PRINT "**** ERROR ****": RESUME 
  518. 30133  IF ERR = 255  THEN  PRINT "OPERATOR ABORT...": END 
  519. 30135  REM 
  520. 30140  REM  GOSUB 4000:REM SHUTDOWN
  521. 30145  REM 
  522. 30150  VTAB 3: PRINT "   I'M SORRY, BUT AN UNEXPECTED ERROR   HAS OCCURED DURING PROGRAM EXECUTION.   IT WOULD BE WISE AT THIS TIME TO RESTOREYOUR FILE WITH A BACKUP FILE."
  523. 30155 X =  PEEK(218) + PEEK(219) *256: PRINT : PRINT "ERROR WAS IN LINE #";X
  524. 30157 ERR =  PEEK(222): PRINT "ERROR #";ERR
  525. 30160  END